library(tidyverse)
library(ggdist)
library(ggside)
library(easystats)
library(patchwork)
library(brms)
df <- read.csv("data/data.csv") |>
mutate(
Date = lubridate::dmy(Date),
Participant = fct_reorder(Participant, Date),
Screen_Refresh = as.character(Screen_Refresh),
Education = fct_relevel(Education, "Doctorate", "Master", "Bachelor", "High School", "Other", "Prefer not to Say"),
Belief = fct_relevel(Belief, "Fake", "Real"),
Stimulus_Interest = case_when(
Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Opposite" ~ TRUE,
Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Same" ~ FALSE,
Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Opposite" ~ FALSE,
Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Same" ~ TRUE,
Sexual_Orientation %in% c("Bisexual", "Queer") ~ TRUE,
TRUE ~ NA
)
)
# head(df[is.na(df$Stimulus_Attract), ])
# Create individual scores for Simulation Monitoring
df <- df |>
group_by(Participant, Belief) |>
summarise(
Confidence = mean(abs(Belief_Confidence)),
n = n() / 109
) |>
pivot_wider(names_from = "Belief", values_from = c("Confidence", "n")) |>
ungroup() |>
merge(df, by = "Participant")
outliers <- c(
# Very short duration for questionnaire in particular + low rating correlations
"5eaef8702b68455d6e130595_ptsga",
"5f0f0a2a8b2a480447f31b21_lqgpz",
"611d03b822d4c8e041ea0c32_m0knb"
)
outliers_partial <- c(
"5dc3485219ca0326027ce91f_37ho9",
"5c6414540821d30001046198_x9q7r",
"60dd7b03f1e72d38230df476_9yh9n",
"5962799cb752840001ca478b_jh4sl",
"5f44c23fbf2ddb80bcdf0edc_dnbny",
"5e80370d48b5f47170e30e5c_5w2gf"
)
We removed 3 participants upon inspection of…
extreme_items <- df |>
group_by(Stimulus, Belief) |>
summarize(n = n() / length(unique(df$Participant))) |>
pivot_wider(values_from = "n", names_from = "Belief") |>
mutate(File = paste0("experiment/stimuli/AMFD/", Stimulus)) |>
arrange(Real) |>
filter(Real < 0.15 | Real > 0.85)
p_item <- df |>
filter(Stimulus %in% extreme_items$Stimulus) |>
mutate(Stimulus = fct_relevel(Stimulus, as.character(extreme_items$Stimulus))) |>
ggplot(aes(x = Belief_Answer, y = Stimulus, fill = Stimulus)) +
ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups") +
geom_vline(xintercept = 0, linetype = "dotted") +
ggimage::geom_image(data = extreme_items, aes(image = File, x = 0, y = Stimulus), size = 0.1, by = "height") +
# scale_y_discrete(expand = c(0.5, 0.5)) +
scale_x_continuous(
limits = c(-1, 1),
expand = c(0, 0),
breaks = c(-1, 0, 1),
label = c("Fake", "", "Real")
) +
scale_fill_viridis_d(option = "inferno") +
labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
guides(fill = "none") +
see::theme_modern() +
theme(
# axis.text.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
)
# p_item
df <- df |>
filter(!Stimulus %in% extreme_items$Stimulus)
We removed 1 trials per participant.
dfsub <- df |>
group_by(Participant) |>
select(Participant, starts_with("Attention"), starts_with("Duration"), n_Fake) |>
slice(1) |>
ungroup() |>
rowwise() |>
mutate(Attention_Check = mean(c(Attention_Check1, Attention_Check2, Attention_Check3))) |>
ungroup() |>
arrange(Attention_Check)
dfsub$r_Trustworthy <- NA
dfsub$r_Attractive <- NA
dfsub$r_Beauty <- NA
for (participant in dfsub$Participant) {
dfsub[dfsub$Participant == participant, "r_Trustworthy"] <- cor(df[df$Participant == participant, "Trustworthy"], df[df$Participant == participant, "Norms_Trustworthy"])
dfsub[dfsub$Participant == participant, "r_Attractive"] <- cor(df[df$Participant == participant, "Attractive"], df[df$Participant == participant, "Norms_Attractive"])
dfsub[dfsub$Participant == participant, "r_Beauty"] <- cor(df[df$Participant == participant, "Beauty"], df[df$Participant == participant, "Norms_Attractive"])
}
data.frame(Participant = c(paste0("Total (n=", nrow(dfsub), ")")), t(sapply(dfsub[2:ncol(dfsub)], mean, na.rm = TRUE))) |>
rbind(dfsub) |>
mutate(Attention_Check = paste0(
insight::format_value(Attention_Check, 1),
" (", insight::format_value(Attention_Check1, 1),
", ",
insight::format_value(Attention_Check2, 1),
", ",
insight::format_value(Attention_Check3, 1),
")"
)) |>
select(-Attention_Check1, -Attention_Check2, -Attention_Check3) |>
datawizard::data_relocate("Attention_Check", 2) |>
knitr::kable() |>
kableExtra::row_spec(1, italic = TRUE) |>
kableExtra::row_spec(which(dfsub$Participant %in% outliers) + 1, background = "#EF9A9A") |>
kableExtra::row_spec(which(dfsub$Participant %in% outliers_partial) + 1, background = "#FFCC80")
| Participant | Attention_Check | Duration_Questionnaires | Duration_Task | n_Fake | r_Trustworthy | r_Attractive | r_Beauty |
|---|---|---|---|---|---|---|---|
| Total (n=103) | 1.0 (1.0, 1.0, 1.0) | 12.09 | 23.7 | 0.445 | 0.268 | 0.442 | 0.465 |
| 611d03b822d4c8e041ea0c32_m0knb | 0.6 (0.6, 0.4, 0.6) | 6.00 | 20.5 | 0.248 | 0.164 | 0.208 | 0.225 |
| 5f0f0a2a8b2a480447f31b21_lqgpz | 0.6 (0.2, 1.0, 0.5) | 164.70 | 17.6 | 0.642 | -0.144 | 0.343 | 0.288 |
| 5962799cb752840001ca478b_jh4sl | 0.7 (1.0, 0.2, 1.0) | 19.93 | 30.4 | 0.284 | 0.063 | 0.344 | 0.326 |
| 5dc3485219ca0326027ce91f_37ho9 | 0.8 (0.5, 1.0, 1.0) | 7.01 | 16.1 | 0.587 | 0.253 | 0.572 | 0.557 |
| 5c6414540821d30001046198_x9q7r | 0.9 (1.0, 1.0, 0.6) | 9.84 | 23.4 | 0.284 | 0.330 | 0.483 | 0.466 |
| 60dd7b03f1e72d38230df476_9yh9n | 0.9 (0.6, 1.0, 1.0) | 12.86 | 19.9 | 0.092 | 0.435 | 0.429 | 0.550 |
| 5f44c23fbf2ddb80bcdf0edc_dnbny | 0.9 (0.7, 1.0, 1.0) | 4.71 | 24.8 | 0.486 | 0.103 | 0.147 | 0.195 |
| 5e80370d48b5f47170e30e5c_5w2gf | 0.9 (0.7, 1.0, 1.0) | 5.64 | 22.8 | 0.440 | 0.350 | 0.604 | 0.612 |
| 5fb7cfde7808523cea8ee891_xlrlw | 1.0 (0.9, 1.0, 1.0) | 6.95 | 17.7 | 0.514 | 0.324 | 0.515 | 0.532 |
| 613e4bf960ca68f8de00e5e7_cfsdt | 1.0 (0.9, 1.0, 1.0) | 11.15 | 23.8 | 0.468 | 0.265 | 0.466 | 0.428 |
| 6115d9fa61078b29b8db91ff_ewn8c | 1.0 (0.9, 1.0, 1.0) | 11.06 | 19.3 | 0.440 | 0.452 | 0.250 | 0.341 |
| 5f1acd8cb55680224c3d452a_56nun | 1.0 (0.9, 1.0, 1.0) | 11.66 | 26.0 | 0.642 | 0.383 | 0.527 | 0.518 |
| 5b8646582c180900019c9eb7_xt3l6 | 1.0 (1.0, 1.0, 1.0) | 20.16 | 21.4 | 0.514 | 0.308 | 0.363 | 0.338 |
| 5d936374253d0a0017f32d96_n98qu | 1.0 (1.0, 1.0, 1.0) | 6.87 | 13.3 | 0.440 | 0.233 | 0.455 | 0.457 |
| 611b86fe4bd6db6f42e4afea_4asue | 1.0 (1.0, 1.0, 1.0) | 17.36 | 36.8 | 0.330 | 0.421 | 0.279 | 0.365 |
| 5f233d7f53212b0e22bf055d_x9368 | 1.0 (1.0, 1.0, 1.0) | 13.32 | 16.7 | 0.624 | 0.430 | 0.603 | 0.619 |
| 5fb015142942a535524f55fc_u1vq2 | 1.0 (1.0, 1.0, 1.0) | 14.47 | 18.4 | 0.624 | 0.428 | 0.575 | 0.598 |
| 5d7f8ffae664ab001967d9d3_7mrcg | 1.0 (1.0, 1.0, 1.0) | 4.83 | 11.5 | 0.468 | 0.306 | 0.209 | 0.361 |
| 613a92a2dbedc6e7aad89199_thehb | 1.0 (1.0, 1.0, 1.0) | 10.85 | 40.0 | 0.541 | 0.305 | 0.462 | 0.456 |
| 5ad63c167f70c10001904bc5_ers7p | 1.0 (1.0, 1.0, 1.0) | 12.18 | 25.6 | 0.413 | 0.298 | 0.466 | 0.521 |
| 5bb511c6689fc5000149c703_d9k0p | 1.0 (1.0, 1.0, 1.0) | 12.56 | 21.8 | 0.083 | 0.405 | -0.168 | 0.351 |
| 5d40a12f4994c40001e4b80c_2ytoa | 1.0 (1.0, 1.0, 1.0) | 13.25 | 21.8 | 0.587 | 0.338 | 0.609 | 0.521 |
| 5eaef8702b68455d6e130595_ptsga | 1.0 (1.0, 1.0, 1.0) | 2.69 | 14.9 | 0.523 | 0.021 | 0.091 | 0.096 |
| 5eb17f5f5b4ec12749a65a24_cmop5 | 1.0 (1.0, 1.0, 1.0) | 11.40 | 18.9 | 0.450 | 0.358 | 0.362 | 0.514 |
| 5ed8e10d54fe053fbc756c72_zknp4 | 1.0 (1.0, 1.0, 1.0) | 7.63 | 26.3 | 0.468 | -0.056 | 0.540 | 0.444 |
| 5f034ecf38c5aa527d056830_2pvm9 | 1.0 (1.0, 1.0, 1.0) | 10.09 | 19.0 | 0.339 | 0.274 | 0.564 | 0.539 |
| 5f3801b18c88962be7831304_ubcua | 1.0 (1.0, 1.0, 1.0) | 8.73 | 16.8 | 0.330 | 0.153 | 0.578 | 0.558 |
| 5faa6cab8ac7a937a5240fcb_xsbot | 1.0 (1.0, 1.0, 1.0) | 10.20 | 14.9 | 0.505 | 0.153 | 0.544 | 0.517 |
| 601941db6605160008690742_twd28 | 1.0 (1.0, 1.0, 1.0) | 6.25 | 13.9 | 0.578 | 0.299 | 0.453 | 0.444 |
| 6036ab8b13ac9c79d7e67e81_ln8ep | 1.0 (1.0, 1.0, 1.0) | 7.14 | 13.4 | 0.651 | 0.273 | 0.265 | 0.312 |
| 60a256f83ef6ada5debc47a9_q7wl4 | 1.0 (1.0, 1.0, 1.0) | 6.03 | 16.0 | 0.321 | 0.218 | 0.520 | 0.451 |
| 60a3a03bc01ba594c9cca88d_v0jdv | 1.0 (1.0, 1.0, 1.0) | 11.76 | 30.0 | 0.495 | 0.406 | 0.258 | 0.410 |
| 60b6c415dbda3236ea22455a_dmezs | 1.0 (1.0, 1.0, 1.0) | 24.73 | 43.0 | 0.450 | 0.263 | 0.628 | 0.613 |
| 60e1eb72b81681d6c856bd7b_uzbeq | 1.0 (1.0, 1.0, 1.0) | 8.62 | 20.8 | 0.706 | 0.439 | 0.631 | 0.435 |
| 60e4b1dcd0eedab1e11019d1_4varz | 1.0 (1.0, 1.0, 1.0) | 8.61 | 33.0 | 0.349 | 0.191 | 0.368 | 0.388 |
| 60f3261b934093c881b85cf6_lnoph | 1.0 (1.0, 1.0, 1.0) | 13.37 | 27.8 | 0.450 | 0.225 | 0.520 | 0.575 |
| 611b1c9ce8ad1ac6db791065_hwlhj | 1.0 (1.0, 1.0, 1.0) | 8.57 | 26.1 | 0.541 | 0.364 | 0.231 | 0.525 |
| 613a972033d79df11a6570de_1u773 | 1.0 (1.0, 1.0, 1.0) | 14.71 | 26.2 | 0.450 | 0.209 | 0.666 | 0.635 |
| 613baa22050360ec21d4437f_9sac0 | 1.0 (1.0, 1.0, 1.0) | 16.64 | 17.6 | 0.688 | 0.106 | 0.195 | 0.178 |
| 614f681bacfa57e3d06529ad_qv0u7 | 1.0 (1.0, 1.0, 1.0) | 15.65 | 30.0 | 0.404 | 0.256 | 0.427 | 0.417 |
| 6160f3629ac70cba36523ff8_zslcv | 1.0 (1.0, 1.0, 1.0) | 9.14 | 23.4 | 0.523 | 0.366 | 0.416 | 0.444 |
| 5c00043a6d931200019bcb9b_wnj27 | 1.0 (1.0, 1.0, 1.0) | 20.36 | 34.7 | 0.284 | 0.543 | 0.582 | 0.634 |
| 5d3f63a92df9f7001bd92a32_oj5t7 | 1.0 (1.0, 1.0, 1.0) | 7.93 | 20.1 | 0.523 | 0.193 | 0.390 | 0.431 |
| 5db9b910001ffa0188426dca_knhee | 1.0 (1.0, 1.0, 1.0) | 6.05 | 25.5 | 0.596 | 0.134 | 0.169 | 0.148 |
| 5ecd37ee75736a068808fa6c_v4ej4 | 1.0 (1.0, 1.0, 1.0) | 10.52 | 16.0 | 0.468 | 0.217 | 0.612 | 0.536 |
| 5fdfd04b9bf07d83b2e5f780_gtb9u | 1.0 (1.0, 1.0, 1.0) | 9.30 | 20.6 | 0.147 | 0.222 | 0.657 | 0.620 |
| 6107133e49bf8db00bd6d389_qkj9f | 1.0 (1.0, 1.0, 1.0) | 11.38 | 29.6 | 0.477 | 0.366 | 0.299 | 0.579 |
| 613a69d8ed1c11f70b3d37c7_yu0z2 | 1.0 (1.0, 1.0, 1.0) | 11.16 | 28.9 | 0.477 | 0.235 | 0.372 | 0.415 |
| 6146385561e8f95ff4f3b5d6_cvm6o | 1.0 (1.0, 1.0, 1.0) | 9.13 | 24.9 | 0.642 | 0.197 | 0.405 | 0.346 |
| 614b55e22ff3944a165736bb_cl98h | 1.0 (1.0, 1.0, 1.0) | 14.66 | 22.6 | 0.450 | 0.441 | 0.580 | 0.514 |
| 616cb46402d68cdfc6e8c8db_xzyj4 | 1.0 (1.0, 1.0, 1.0) | 4.59 | 25.4 | 0.211 | 0.000 | 0.217 | 0.188 |
| 6294ce94ea81c4554b141010_u5v5t | 1.0 (1.0, 1.0, 1.0) | 8.28 | 18.7 | 0.339 | 0.294 | 0.491 | 0.461 |
| 558fa9dffdf99b7ce2924662_58ffp | 1.0 (1.0, 1.0, 1.0) | 10.06 | 34.9 | 0.624 | 0.314 | 0.451 | 0.470 |
| 572b96ba3ab9df000dbb4461_bq660 | 1.0 (1.0, 1.0, 1.0) | 14.16 | 16.5 | 0.202 | 0.059 | 0.513 | 0.540 |
| 57b8e70f35624400013d690c_boeew | 1.0 (1.0, 1.0, 1.0) | 5.71 | 19.7 | 0.440 | 0.402 | 0.550 | 0.589 |
| 59501095c58c85000101dc57_od0ny | 1.0 (1.0, 1.0, 1.0) | 5.81 | 26.6 | 0.541 | 0.377 | 0.495 | 0.458 |
| 595bd5c85ae9a80001ce3426_32tr4 | 1.0 (1.0, 1.0, 1.0) | 8.43 | 19.4 | 0.413 | 0.259 | 0.477 | 0.549 |
| 5a7875355292b80001227f63_uh6o3 | 1.0 (1.0, 1.0, 1.0) | 11.53 | 24.4 | 0.450 | 0.399 | 0.513 | 0.474 |
| 5baf6705848bbd0001d6fc8a_kahs0 | 1.0 (1.0, 1.0, 1.0) | 12.03 | 32.5 | 0.486 | 0.266 | 0.482 | 0.531 |
| 5c573e54e9813700018acc31_kv5lw | 1.0 (1.0, 1.0, 1.0) | 6.72 | 23.6 | 0.514 | 0.342 | 0.415 | 0.396 |
| 5dbd7193e8add82b72d795f2_8g8wk | 1.0 (1.0, 1.0, 1.0) | 11.12 | 22.9 | 0.266 | 0.461 | 0.577 | 0.624 |
| 5de476f9b5b7ff447db5c4aa_chlcj | 1.0 (1.0, 1.0, 1.0) | 10.25 | 17.6 | 0.468 | 0.307 | 0.514 | 0.459 |
| 5e7bcff00fb32c0f51fea882_bvbwo | 1.0 (1.0, 1.0, 1.0) | 15.14 | 19.2 | 0.229 | 0.207 | 0.485 | 0.490 |
| 5e8dddaf3d1b57068b77b2f2_8ebal | 1.0 (1.0, 1.0, 1.0) | 12.53 | 32.1 | 0.404 | 0.507 | 0.540 | 0.636 |
| 5eb170206e577a07e9954c65_csm2p | 1.0 (1.0, 1.0, 1.0) | 15.61 | 23.0 | 0.459 | 0.477 | 0.688 | 0.718 |
| 5ece75528f582a08555e0a3e_21ckq | 1.0 (1.0, 1.0, 1.0) | 13.74 | 48.5 | 0.523 | 0.453 | 0.500 | 0.613 |
| 5ef0a866cd9cde0fcd0d2f77_rvy90 | 1.0 (1.0, 1.0, 1.0) | 10.57 | 26.2 | 0.532 | 0.200 | 0.599 | 0.597 |
| 5f09068244f84c18faaa74bc_q0ukp | 1.0 (1.0, 1.0, 1.0) | 6.97 | 19.3 | 0.450 | -0.031 | 0.467 | 0.496 |
| 5f108dea719866356702d26f_p836j | 1.0 (1.0, 1.0, 1.0) | 5.29 | 17.4 | 0.422 | -0.226 | 0.413 | 0.422 |
| 5f49424d243bb347aaec4897_ggzqw | 1.0 (1.0, 1.0, 1.0) | 8.61 | 25.3 | 0.303 | 0.434 | 0.518 | 0.475 |
| 5f5e7de4c81d3672642cd612_hpyto | 1.0 (1.0, 1.0, 1.0) | 7.09 | 19.1 | 0.532 | 0.269 | 0.524 | 0.300 |
| 5f600669b846780f0fe45709_erd2u | 1.0 (1.0, 1.0, 1.0) | 13.40 | 31.0 | 0.514 | 0.310 | 0.587 | 0.645 |
| 5f761e5106b786071f45b4aa_78zle | 1.0 (1.0, 1.0, 1.0) | 11.56 | 27.8 | 0.385 | 0.048 | 0.207 | 0.219 |
| 5f7ebad5cf009c196fd54b2b_d68uh | 1.0 (1.0, 1.0, 1.0) | 8.39 | 15.6 | 0.495 | 0.404 | 0.674 | 0.659 |
| 5f97e6601f6d0e016087fc91_h6pvt | 1.0 (1.0, 1.0, 1.0) | 4.71 | 26.9 | 0.239 | 0.051 | 0.166 | 0.289 |
| 5f9aba6600cdf11f1c9b915c_cakh2 | 1.0 (1.0, 1.0, 1.0) | 26.74 | 46.8 | 0.394 | 0.266 | 0.325 | 0.357 |
| 5fb633dfaeda3f0aa05eefad_4t92s | 1.0 (1.0, 1.0, 1.0) | 8.18 | 18.1 | 0.505 | 0.289 | 0.521 | 0.499 |
| 5ff4a242cbe069bc27d9278b_relyq | 1.0 (1.0, 1.0, 1.0) | 6.51 | 14.0 | 0.183 | 0.225 | 0.572 | 0.540 |
| 603f6e643234e512fc197ae1_vowxj | 1.0 (1.0, 1.0, 1.0) | 11.40 | 32.7 | 0.486 | 0.304 | 0.538 | 0.281 |
| 6045cb37ffdadc70e734a73b_ns96q | 1.0 (1.0, 1.0, 1.0) | 17.87 | 52.2 | 0.541 | 0.448 | 0.427 | 0.429 |
| 604b169fe4b7991ec08da3a6_9o72l | 1.0 (1.0, 1.0, 1.0) | 7.21 | 23.4 | 0.330 | 0.111 | 0.456 | 0.419 |
| 605a1c7fe0ca143242990e95_528pg | 1.0 (1.0, 1.0, 1.0) | 13.97 | 23.1 | 0.560 | 0.388 | 0.491 | 0.526 |
| 6081728972120aa7f9685791_aqvhb | 1.0 (1.0, 1.0, 1.0) | 25.43 | 41.3 | 0.578 | 0.312 | 0.494 | 0.573 |
| 6099df8e57bf74dbc121c774_5jnsc | 1.0 (1.0, 1.0, 1.0) | 6.22 | 26.6 | 0.459 | 0.510 | 0.502 | 0.512 |
| 60a6ba026f8bd75b67b23c97_z458q | 1.0 (1.0, 1.0, 1.0) | 11.75 | 14.6 | 0.596 | 0.241 | 0.475 | 0.518 |
| 60b8b5dcb46db8ae98d0b047_4u9jy | 1.0 (1.0, 1.0, 1.0) | 4.86 | 21.4 | 0.367 | 0.151 | -0.220 | 0.445 |
| 60cefa69352cbf2549f2bf35_as90e | 1.0 (1.0, 1.0, 1.0) | 8.50 | 19.2 | 0.486 | 0.513 | 0.539 | 0.520 |
| 60ddfb3db6a71ad9ba75e387_u85bv | 1.0 (1.0, 1.0, 1.0) | 8.48 | 14.7 | 0.550 | 0.068 | 0.502 | 0.435 |
| 61081aab1dad0a92827a371d_bbpfc | 1.0 (1.0, 1.0, 1.0) | 8.87 | 21.6 | 0.486 | 0.285 | 0.561 | 0.532 |
| 61093d97f7bf8a4f8117eb82_yzsmx | 1.0 (1.0, 1.0, 1.0) | 13.15 | 24.5 | 0.550 | 0.122 | 0.259 | 0.316 |
| 610d97bf0ee9babdb89986ea_3t039 | 1.0 (1.0, 1.0, 1.0) | 8.71 | 20.4 | 0.450 | 0.527 | 0.584 | 0.556 |
| 61253683f41abc76c81ec082_xc4uu | 1.0 (1.0, 1.0, 1.0) | 7.45 | 19.6 | 0.294 | 0.346 | 0.559 | 0.546 |
| 612ba6c594a6d54154a88ae7_m0duf | 1.0 (1.0, 1.0, 1.0) | 6.73 | 12.5 | 0.339 | 0.513 | 0.508 | 0.445 |
| 61330f324c6c15a907dc2706_zg72v | 1.0 (1.0, 1.0, 1.0) | 9.53 | 28.0 | 0.404 | 0.252 | 0.432 | 0.495 |
| 613af39692992acbacdbbbbc_0g94n | 1.0 (1.0, 1.0, 1.0) | 17.26 | 39.3 | 0.394 | 0.112 | 0.458 | 0.518 |
| 6151a21b24b1ef1bc130b97d_cazbl | 1.0 (1.0, 1.0, 1.0) | 14.07 | 24.8 | 0.615 | 0.050 | 0.371 | 0.359 |
| 61545919a17f1331cb7b33a7_mszfq | 1.0 (1.0, 1.0, 1.0) | 12.28 | 20.4 | 0.018 | 0.182 | 0.359 | 0.376 |
| 61687ebcd2a35ffb762d1928_0hgcq | 1.0 (1.0, 1.0, 1.0) | 13.01 | 40.4 | 0.413 | 0.299 | 0.496 | 0.557 |
| 616e5ae706e970fe0aff99b6_561t0 | 1.0 (1.0, 1.0, 1.0) | 6.15 | 25.2 | 0.624 | 0.453 | 0.548 | 0.497 |
| 6266a4e5846e1e41812a0432_ds50m | 1.0 (1.0, 1.0, 1.0) | 6.33 | 16.5 | 0.477 | 0.201 | 0.502 | 0.488 |
| 62e416f154e4c9e7f39d5cf7_2a9nx | 1.0 (1.0, 1.0, 1.0) | 6.52 | 9.3 | 0.468 | 0.089 | 0.434 | 0.443 |
| 5ec554706960444f4a1768de_uma91 | 1.0 (1.0, 1.0, 1.0) | 8.58 | 16.4 | 0.248 | -0.142 | 0.188 | 0.513 |
| 610aa32712b5d159232e01ca_2qade | 1.0 (1.0, 1.0, 1.0) | 6.85 | 20.9 | 0.523 | 0.403 | 0.548 | 0.556 |
# kableExtra::row_spec(which(str_detect(dfsub$Participant, "613a972033d79df11a6570de")) + 1, background = "green")
p_att <- dfsub |>
select(Participant, starts_with("Att")) |>
pivot_longer(-Participant) |>
# mutate(name = str_remove(name, "Cor_")) |>
ggplot(aes(x = Participant, y = value)) +
geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
scale_y_continuous(expand = c(0, 0)) +
scale_fill_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
scale_color_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
see::theme_modern() +
theme(
axis.text.x = element_text(angle = 45, hjust = 1),
legend.position = "top"
) +
labs(y = "Score", fill = "") +
guides(color = "none") +
ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0))
p_time <- dfsub |>
select(Participant, starts_with("Duration")) |>
pivot_longer(-Participant) |>
mutate(name = str_remove(name, "Duration_")) |>
ggplot(aes(x = Participant, y = value)) +
geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
scale_y_continuous(expand = c(0, 0)) +
scale_fill_manual(values = c("#4CAF50", "#FF9800")) +
scale_color_manual(values = c("#4CAF50", "#FF9800")) +
see::theme_modern() +
theme(
axis.text.x = element_text(angle = 45, hjust = 1),
legend.position = "top"
) +
labs(y = "Duration (min)", fill = "") +
guides(color = "none") +
ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0))
p_cor <- dfsub |>
select(Participant, starts_with("r_")) |>
pivot_longer(-Participant) |>
mutate(name = str_remove(name, "r_")) |>
ggplot(aes(x = Participant, y = value)) +
geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
scale_y_continuous(expand = c(0, 0)) +
scale_fill_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
scale_color_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
see::theme_modern() +
theme(
axis.text.x = element_text(
angle = 45, hjust = 1,
color = ifelse(levels(dfsub$Participant) %in% outliers, "red", ifelse(levels(dfsub$Participant) %in% outliers_partial, "orange", "black"))
),
legend.position = "top"
) +
labs(y = "Correlation", fill = "") +
guides(color = "none") +
ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0))
(p_att + theme(axis.text.x = element_blank())) /
(p_time + theme(axis.text.x = element_blank())) /
(p_cor)
df <- df |>
filter(!Participant %in% outliers)
dfsub <- df |>
group_by(Participant) |>
select(Participant, Age, Sex, Sexual_Orientation, Ethnicity, Education, Nationality, Device_OS, starts_with("Screen"), starts_with("IPIP"), starts_with("Social_"), starts_with("FFNI_"), starts_with("GPTS_"), starts_with("IUS_"), starts_with("SelfAttractiveness"), starts_with("AI"), n_Real, Confidence_Fake, Confidence_Real) |>
slice(1) |>
ungroup()
The final sample included 100 participants (Mean age = 27.9, SD = 8.5, range: [19, 66]; Sex: 48.0% females, 52.0% males, 0.0% other; Education: Doctorate, 2.00%; Master, 18.00%; Bachelor, 34.00%; High School, 40.00%; Other, 5.00%; Prefer not to Say, 1.00%).
plot_distribution <- function(dfsub, what = "Age", title = what, subtitle = "", fill = "orange") {
dfsub |>
ggplot(aes_string(x = what)) +
geom_density(fill = fill) +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0)) +
ggtitle(title, subtitle = subtitle) +
theme_modern() +
theme(
plot.title = element_text(face = "bold", hjust = 0.5),
plot.subtitle = element_text(face = "italic", hjust = 0.5),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank()
)
}
plot_waffle <- function(dfsub, what = "Nationality", title = what, rows = 10, size = 4) {
# library(emojifont)
ggwaffle::waffle_iron(dfsub, what, rows = rows) |>
# mutate(label = emojifont::fontawesome('fa-smiley')) |>
# mutate(label = emojifont::emoji('smiley')) |>
ggplot(aes(x, y)) +
geom_point(aes(color = group), shape = "square", size = size) +
# ggwaffle::geom_waffle(color = "white") +
# geom_point() +
# geom_text(aes(color=group ,label=label), family='fontawesome-webfont', size=4) +
# geom_text(aes(color=group ,label=label), family='EmojiOne', size=4) +
coord_equal() +
ggtitle(title) +
labs(fill = "", color = "") +
# scale_x_continuous(expand = c(0, 0)) +
# scale_y_continuous(expand = c(0, 0)) +
theme_void() +
# ggwaffle::theme_waffle() +
theme(plot.title = element_text(face = "bold", hjust = 0.5))
}
p1 <- estimate_density(dfsub$Age) |>
ggplot(aes(x = x, y = y)) +
geom_area(fill = "#FF9800") +
labs(x = "Age", y = "") +
theme_modern()
p2 <- plot_waffle(dfsub, "Sex") +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63", "Other" = "#FF9800"))
p3 <- plot_waffle(dfsub, "Sexual_Orientation")
p4 <- plot_waffle(dfsub, "Education") +
scale_fill_viridis_d()
p5 <- dfsub |>
group_by(Nationality) |>
mutate(n = n()) |>
ungroup() |>
mutate(Nationality = fct_reorder(Nationality, desc(n))) |>
ggplot(aes(Nationality)) +
geom_bar(aes(fill = Nationality)) +
scale_fill_viridis_d(guide = "none") +
theme_modern() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
p6 <- plot_waffle(dfsub, "Ethnicity") +
scale_fill_manual(values = c("Latino" = "#FF5722", "Asian" = "#FF9800", "Caucasian" = "#2196F3", "African" = "#4CAF50", "Jewish" = "#9C27B0", "Mixed" = "#795548"))
p7 <- plot_waffle(dfsub, "Screen_Resolution", title = "Screen Resolution") +
scale_fill_pizza_d() +
guides(fill = "none")
p8 <- plot_waffle(dfsub, "Device_OS", title = "Device OS") +
scale_fill_bluebrown_d()
# p10 <- plot_waffle(dfsub, "Screen_Refresh") +
# scale_fill_viridis_d()
patchwork::wrap_plots(list(p1, p2, p3, p5, p4, p6))
# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
mutate(Participant = fct_relevel(Participant, df |>
group_by(Participant) |>
summarize(Belief_Answer = mean(Belief_Answer)) |>
ungroup() |>
arrange(Belief_Answer) |>
pull(Participant) |>
as.character())) |>
# mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
geom_vline(xintercept = 0, linetype = "dotted") +
scale_y_discrete(expand = c(0.02, 0)) +
scale_x_continuous(
limits = c(-1, 1),
expand = c(0, 0),
breaks = c(-0.95, 0, 0.95),
label = c("Fake", "", "Real")
) +
scale_fill_viridis_d() +
labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
guides(fill = "none") +
see::theme_modern() +
theme(
axis.text.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "grey", color = "white") +
ggside::scale_xsidey_continuous(expand = c(0, 0))
IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")
preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
for (y in IVs) {
if (x == y) next
print(paste(y, "~", x))
model <- glmmTMB::glmmTMB(as.formula(
paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
),
data = df,
family = glmmTMB::beta_family()
)
# model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
# random = list(Participant=~1, Stimulus=~1),
# data = df,
# family=mgcv::betar())
pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
pred$y <- y
pred <- data_rename(pred, x, "Score")
pred$x <- x
preds <- rbind(preds, pred)
dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
}
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"
dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
dats |>
ggplot(aes(x = Score, y = Predicted)) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
# geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
facet_grid(y ~ x, switch = "both") +
theme_modern() +
labs(title = "Collinearity in the Stimuli Ratings") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
axis.title.x = element_blank(),
axis.title.y = element_blank(),
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggnewscale::new_scale_fill() +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
data = df,
family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)
m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
df |>
ggplot(aes(x = Delay, y = Real)) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
geom_line(data = pred, aes(y = Predicted), color = "red") +
scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
theme_modern() +
labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
theme(
aspect.ratio = 1,
strip.background = element_blank(),
strip.placement = "outside",
plot.title = element_text(face = "bold", hjust = 0.5)
) +
ggside::geom_xsidedensity(fill = "#795548", color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0)) +
ggside::ggside(collapse = "all")
parameters::parameters(model)
## # Fixed Effects
##
## Parameter | Log-Odds | SE | 95% CI | z | p
## --------------------------------------------------------------------
## (Intercept) | 0.39 | 0.10 | [ 0.20, 0.58] | 3.94 | < .001
## Delay | -6.62e-03 | 2.91e-03 | [-0.01, 0.00] | -2.27 | 0.023
##
## # Random Effects
##
## Parameter | Coefficient
## -----------------------------------------
## SD (Intercept: Participant) | 0.65
## SD (Intercept: Stimulus) | 0.59
make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
# Models
m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
data = df,
family = "binomial"
)
y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
# gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
# data=df,
# algorithm="sampling",
# family = "bernoulli")
# trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
# slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
# trend$Trend <- interpret_pd(slope$pd)
# trend$group <- 0
# trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))
m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
data = df,
family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
y_conf <- y_conf |>
mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))
# Significance
param <- parameters::parameters(m_real, effects = "fixed", keep = var)
sig <- data.frame(
x = 0.5,
y = y_real[c(11, 32), "Predicted"] + c(0.05, -0.05),
p = c(min(param$p[c(1, 3)]), min(param$p[c(2, 4)])),
Sex = c("Female", "Male")
)
sig$label <- format_p(sig$p, stars_only = TRUE)
# Plot
p <- df |>
ggplot(aes_string(x = var, y = "Real")) +
stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
scale_fill_gradientn(colors = c("white", fill), guide = "none") +
ggnewscale::new_scale_fill() +
geom_hline(yintercept = 0.5, linetype = "dotted") +
# geom_point2(alpha = 0.25, size = 4, color = "black") +
geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
geom_line(data = y_real, aes(y = Predicted, color = Sex), size=1) +
# geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
# geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
geom_text(data = sig, aes(y = y, x = x, label = label, color = Sex), size = 8) +
scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
labs(y = "Simulation Monitoring") +
guides(fill = guide_legend(override.aes = list(alpha = 1))) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fill, color = "white") +
ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
list(p = p, model_belief = m_real, model_confidence = m_conf)
}
rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Beauty, 2) + Trustworthy + (1|Participant) + (1|Stimulus)",
var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Trustworthy, 2) + Beauty + (1|Participant) + (1|Stimulus)",
var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
formula = "Sex / poly(Familiar, 2) + (1|Participant) + (1|Stimulus)",
var = "Familiar", fill = "#2196F3"
)
fig1a <- (rez_at$p +
theme(axis.text.x = element_blank()) +
labs(x = "Attractiveness") |
rez_gl$p +
labs(x = "Beauty") +
theme(
axis.text.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank()
)
) /
(rez_tr$p +
labs(x = "Trustworthiness") |
rez_fa$p +
labs(x = "Familiarity") +
theme(
axis.text.y = element_blank(),
axis.title.y = element_blank()
)
) +
plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
plot_layout(guides = "collect") &
theme(legend.position='top', legend.title = element_blank())
fig1a
parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive")
## # Fixed Effects
##
## Parameter | Log-Odds | SE | 95% CI | z | p
## --------------------------------------------------------------------------------------
## Sex [Female] * poly(Attractive, 2)1 | 1.00 | 3.64 | [-6.13, 8.13] | 0.28 | 0.783
## Sex [Male] * poly(Attractive, 2)1 | 16.37 | 4.39 | [ 7.76, 24.98] | 3.73 | < .001
## Sex [Female] * poly(Attractive, 2)2 | 7.77 | 3.25 | [ 1.41, 14.13] | 2.40 | 0.017
## Sex [Male] * poly(Attractive, 2)2 | 4.61 | 5.22 | [-5.61, 14.83] | 0.88 | 0.377
performance::r2(rez_at$model_belief)
## # R2 for Mixed Models
##
## Conditional R2: 0.197
## Marginal R2: 0.028
performance::icc(rez_at$model_belief, by_group = TRUE)
## # ICC by Group
##
## Group | ICC
## -------------------
## Participant | 0.086
## Stimulus | 0.087
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive")
## # Fixed Effects
##
## Parameter | Coefficient | SE | 95% CI | z | p
## -------------------------------------------------------------------------------------------------------
## Belief [Fake] * SexFemale * poly(Attractive, 2)1 | 0.98 | 2.59 | [ -4.09, 6.06] | 0.38 | 0.704
## Belief [Real] * SexFemale * poly(Attractive, 2)1 | 2.13 | 1.87 | [ -1.54, 5.81] | 1.14 | 0.255
## Belief [Fake] * SexMale * poly(Attractive, 2)1 | 2.65 | 3.41 | [ -4.02, 9.33] | 0.78 | 0.436
## Belief [Real] * SexMale * poly(Attractive, 2)1 | 0.78 | 2.64 | [ -4.39, 5.94] | 0.30 | 0.768
## Belief [Fake] * SexFemale * poly(Attractive, 2)2 | 3.35 | 2.33 | [ -1.21, 7.92] | 1.44 | 0.150
## Belief [Real] * SexFemale * poly(Attractive, 2)2 | 4.38 | 1.74 | [ 0.96, 7.79] | 2.51 | 0.012
## Belief [Fake] * SexMale * poly(Attractive, 2)2 | -8.85 | 4.57 | [-17.81, 0.11] | -1.94 | 0.053
## Belief [Real] * SexMale * poly(Attractive, 2)2 | 5.11 | 2.77 | [ -0.32, 10.53] | 1.85 | 0.065
parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")
## # Fixed Effects
##
## Parameter | Log-Odds | SE | 95% CI | z | p
## ----------------------------------------------------------------------------------
## Sex [Female] * poly(Beauty, 2)1 | -0.38 | 3.64 | [-7.52, 6.76] | -0.10 | 0.917
## Sex [Male] * poly(Beauty, 2)1 | 9.93 | 4.12 | [ 1.86, 18.00] | 2.41 | 0.016
## Sex [Female] * poly(Beauty, 2)2 | 3.30 | 3.30 | [-3.17, 9.77] | 1.00 | 0.317
## Sex [Male] * poly(Beauty, 2)2 | 7.60 | 4.41 | [-1.04, 16.24] | 1.72 | 0.085
performance::r2(rez_gl$model_belief)
## # R2 for Mixed Models
##
## Conditional R2: 0.192
## Marginal R2: 0.031
performance::icc(rez_gl$model_belief, by_group = TRUE)
## # ICC by Group
##
## Group | ICC
## -------------------
## Participant | 0.087
## Stimulus | 0.079
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty")
## # Fixed Effects
##
## Parameter | Coefficient | SE | 95% CI | z | p
## ---------------------------------------------------------------------------------------------------
## Belief [Fake] * SexFemale * poly(Beauty, 2)1 | -1.81 | 2.45 | [ -6.60, 2.99] | -0.74 | 0.460
## Belief [Real] * SexFemale * poly(Beauty, 2)1 | 2.54 | 2.00 | [ -1.38, 6.46] | 1.27 | 0.203
## Belief [Fake] * SexMale * poly(Beauty, 2)1 | -1.83 | 3.28 | [ -8.25, 4.59] | -0.56 | 0.576
## Belief [Real] * SexMale * poly(Beauty, 2)1 | 2.05 | 2.38 | [ -2.62, 6.72] | 0.86 | 0.390
## Belief [Fake] * SexFemale * poly(Beauty, 2)2 | 6.61 | 2.37 | [ 1.98, 11.25] | 2.79 | 0.005
## Belief [Real] * SexFemale * poly(Beauty, 2)2 | 2.57 | 1.96 | [ -1.27, 6.40] | 1.31 | 0.190
## Belief [Fake] * SexMale * poly(Beauty, 2)2 | -5.71 | 3.34 | [-12.26, 0.83] | -1.71 | 0.087
## Belief [Real] * SexMale * poly(Beauty, 2)2 | 4.55 | 2.46 | [ -0.28, 9.38] | 1.85 | 0.065
parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy")
## # Fixed Effects
##
## Parameter | Log-Odds | SE | 95% CI | z | p
## ---------------------------------------------------------------------------------------
## Sex [Female] * poly(Trustworthy, 2)1 | 11.58 | 3.79 | [ 4.15, 19.01] | 3.05 | 0.002
## Sex [Male] * poly(Trustworthy, 2)1 | 6.14 | 3.78 | [-1.28, 13.55] | 1.62 | 0.105
## Sex [Female] * poly(Trustworthy, 2)2 | -0.07 | 3.92 | [-7.75, 7.61] | -0.02 | 0.986
## Sex [Male] * poly(Trustworthy, 2)2 | 0.26 | 3.96 | [-7.51, 8.02] | 0.07 | 0.948
performance::r2(rez_tr$model_belief)
## # R2 for Mixed Models
##
## Conditional R2: 0.183
## Marginal R2: 0.027
performance::icc(rez_tr$model_belief, by_group = TRUE)
## # ICC by Group
##
## Group | ICC
## -------------------
## Participant | 0.085
## Stimulus | 0.076
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy")
## # Fixed Effects
##
## Parameter | Coefficient | SE | 95% CI | z | p
## -------------------------------------------------------------------------------------------------------
## Belief [Fake] * SexFemale * poly(Trustworthy, 2)1 | 2.09 | 2.46 | [-2.73, 6.90] | 0.85 | 0.396
## Belief [Real] * SexFemale * poly(Trustworthy, 2)1 | 1.22 | 2.53 | [-3.74, 6.19] | 0.48 | 0.629
## Belief [Fake] * SexMale * poly(Trustworthy, 2)1 | -3.23 | 2.80 | [-8.73, 2.26] | -1.15 | 0.249
## Belief [Real] * SexMale * poly(Trustworthy, 2)1 | 0.43 | 2.24 | [-3.95, 4.82] | 0.19 | 0.847
## Belief [Fake] * SexFemale * poly(Trustworthy, 2)2 | 1.34 | 2.64 | [-3.83, 6.51] | 0.51 | 0.612
## Belief [Real] * SexFemale * poly(Trustworthy, 2)2 | 6.64 | 2.41 | [ 1.92, 11.37] | 2.75 | 0.006
## Belief [Fake] * SexMale * poly(Trustworthy, 2)2 | -3.99 | 2.81 | [-9.49, 1.52] | -1.42 | 0.156
## Belief [Real] * SexMale * poly(Trustworthy, 2)2 | 0.57 | 2.32 | [-3.97, 5.12] | 0.25 | 0.805
parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar")
## # Fixed Effects
##
## Parameter | Log-Odds | SE | 95% CI | z | p
## -------------------------------------------------------------------------------------
## Sex [Female] * poly(Familiar, 2)1 | 3.95 | 4.00 | [ -3.88, 11.78] | 0.99 | 0.323
## Sex [Male] * poly(Familiar, 2)1 | 9.46 | 4.97 | [ -0.27, 19.20] | 1.90 | 0.057
## Sex [Female] * poly(Familiar, 2)2 | -2.14 | 3.71 | [ -9.42, 5.14] | -0.58 | 0.564
## Sex [Male] * poly(Familiar, 2)2 | -2.73 | 4.60 | [-11.74, 6.29] | -0.59 | 0.554
performance::r2(rez_fa$model_belief)
## # R2 for Mixed Models
##
## Conditional R2: 0.199
## Marginal R2: 0.011
performance::icc(rez_fa$model_belief, by_group = TRUE)
## # ICC by Group
##
## Group | ICC
## -------------------
## Participant | 0.106
## Stimulus | 0.085
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar")
## # Fixed Effects
##
## Parameter | Coefficient | SE | 95% CI | z | p
## ------------------------------------------------------------------------------------------------------
## Belief [Fake] * SexFemale * poly(Familiar, 2)1 | 5.14 | 2.64 | [ -0.04, 10.31] | 1.95 | 0.052
## Belief [Real] * SexFemale * poly(Familiar, 2)1 | -1.06 | 2.09 | [ -5.16, 3.04] | -0.51 | 0.612
## Belief [Fake] * SexMale * poly(Familiar, 2)1 | -12.38 | 3.67 | [-19.57, -5.19] | -3.37 | < .001
## Belief [Real] * SexMale * poly(Familiar, 2)1 | 9.83 | 2.98 | [ 4.00, 15.67] | 3.30 | < .001
## Belief [Fake] * SexFemale * poly(Familiar, 2)2 | 0.55 | 2.45 | [ -4.26, 5.36] | 0.22 | 0.822
## Belief [Real] * SexFemale * poly(Familiar, 2)2 | -0.73 | 2.14 | [ -4.93, 3.46] | -0.34 | 0.732
## Belief [Fake] * SexMale * poly(Familiar, 2)2 | 7.06 | 4.07 | [ -0.92, 15.05] | 1.73 | 0.083
## Belief [Real] * SexMale * poly(Familiar, 2)2 | -1.93 | 2.64 | [ -7.12, 3.25] | -0.73 | 0.464
cor_test(dfsub, "SelfAttractiveness1", "SelfAttractiveness2")
## Parameter1 | Parameter2 | r | 95% CI | t(98) | p
## -----------------------------------------------------------------------------------
## SelfAttractiveness1 | SelfAttractiveness2 | 0.88 | [0.82, 0.92] | 18.19 | < .001***
##
## Observations: 100
df$Self_Attractiveness <- rowMeans(df[c("SelfAttractiveness1", "SelfAttractiveness2")])
m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Attractive, 2) * Self_Attractiveness) + (1 | Participant) + (1 | Stimulus),
data = filter(df, Stimulus_Interest == TRUE),
family = "binomial"
)
parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness")
## # Fixed Effects
##
## Parameter | Log-Odds | SE | 95% CI | z | p
## --------------------------------------------------------------------------------------------------------------
## Sex [Female] * Self Attractiveness | 1.32 | 0.96 | [ -0.56, 3.21] | 1.38 | 0.169
## Sex [Male] * Self Attractiveness | -2.21 | 1.64 | [ -5.42, 1.00] | -1.35 | 0.178
## Sex [Female] * poly(Attractive, 2)1 * Self Attractiveness | -22.26 | 21.07 | [-63.56, 19.04] | -1.06 | 0.291
## Sex [Male] * poly(Attractive, 2)1 * Self Attractiveness | 32.32 | 33.75 | [-33.83, 98.46] | 0.96 | 0.338
## Sex [Female] * poly(Attractive, 2)2 * Self Attractiveness | 12.20 | 14.19 | [-15.61, 40.01] | 0.86 | 0.390
## Sex [Male] * poly(Attractive, 2)2 * Self Attractiveness | -14.63 | 32.37 | [-78.07, 48.80] | -0.45 | 0.651
m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Beauty, 2) * Self_Attractiveness) + Trustworthy + (1 | Participant) + (1 | Stimulus),
data = filter(df, Stimulus_Interest == TRUE),
family = "binomial"
)
parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness")
## # Fixed Effects
##
## Parameter | Log-Odds | SE | 95% CI | z | p
## -----------------------------------------------------------------------------------------------------------
## Sex [Female] * Self Attractiveness | 0.98 | 1.00 | [ -0.97, 2.93] | 0.98 | 0.326
## Sex [Male] * Self Attractiveness | -1.79 | 1.69 | [ -5.10, 1.52] | -1.06 | 0.290
## Sex [Female] * poly(Beauty, 2)1 * Self Attractiveness | -26.06 | 15.71 | [-56.84, 4.72] | -1.66 | 0.097
## Sex [Male] * poly(Beauty, 2)1 * Self Attractiveness | 43.68 | 28.82 | [-12.80, 100.17] | 1.52 | 0.130
## Sex [Female] * poly(Beauty, 2)2 * Self Attractiveness | 8.39 | 13.18 | [-17.45, 34.22] | 0.64 | 0.525
## Sex [Male] * poly(Beauty, 2)2 * Self Attractiveness | -6.84 | 29.31 | [-64.28, 50.61] | -0.23 | 0.816
make_correlation <- function(x, y) {
cor <- correlation::correlation(x,
y,
bayesian = TRUE,
bayesian_prior = "medium.narrow",
sort = TRUE
) |>
datawizard::data_remove(c("ROPE_Percentage"))
cor$`BF (Spearman)` <- format_bf(
correlation::correlation(
x, y,
bayesian = TRUE,
ranktransform = TRUE,
bayesian_prior = "medium.narrow"
)$BF,
name = NULL, stars = TRUE
)
cor |>
arrange(desc(BF))
}
plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
param <- cor_test(dfsub, x, y, bayesian = TRUE)
# Format stat output
r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")
stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")
label <- data.frame(
x = min(dfsub[[x]], na.rm = TRUE),
y = max(dfsub[[y]], na.rm = TRUE),
label = stat
)
# Plot
dfsub |>
ggplot(aes_string(x = x, y = y)) +
geom_point2(
size = 3,
color = fillx,
# color = DVs[x],
alpha = 2 / 3
) +
geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
labs(y = ylab, x = xlab) +
geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
theme_modern(axis.title.space = 5) +
ggside::geom_xsidedensity(fill = fillx, color = "white") +
ggside::geom_ysidedensity(fill = fill, color = "white") +
ggside::theme_ggside_void() +
ggside::scale_ysidex_continuous(expand = c(0, 0)) +
ggside::scale_xsidey_continuous(expand = c(0, 0))
}
sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.21 | [-0.38, -0.02] | 98.65%* | Beta (5.20 +- 5.20) | 3.57* | 3.55*
## Confidence_Fake | IPIP6_Openness | 0.16 | [-0.02, 0.35] | 95.40% | Beta (5.20 +- 5.20) | 1.40 | 1.12
##
## Observations: 100
rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)
efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
##
## Variable | MR1 | MR2 | MR3 | Complexity | Uniqueness
## -------------------------------------------------------------------------------
## AI_4_DailyLife | 0.88 | 0.07 | 0.15 | 1.07 | 0.20
## AI_8_Exciting | 0.79 | 0.20 | 0.14 | 1.20 | 0.31
## AI_9_Applications | 0.79 | 0.09 | 0.17 | 1.12 | 0.34
## AI_7_RealisticVideos | 0.14 | 0.74 | -4.43e-03 | 1.07 | 0.43
## AI_5_ImitatingReality | 0.29 | 0.63 | 0.05 | 1.42 | 0.52
## AI_3_VideosReal | -0.15 | 0.50 | -0.12 | 1.30 | 0.71
## AI_1_RealisticImages | 0.18 | 0.49 | 0.19 | 1.56 | 0.69
## AI_2_Unethical | 0.18 | -7.70e-04 | 0.78 | 1.11 | 0.35
## AI_6_Dangerous | 0.17 | -0.12 | 0.62 | 1.23 | 0.57
## AI_10_FaceErrors | 0.02 | 0.07 | 0.25 | 1.14 | 0.93
##
## The 3 latent factors (varimax rotation) accounted for 49.60% of the total variance of the original data (MR1 = 22.50%, MR2 = 15.19%, MR3 = 11.91%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
cbind(dfsub)
r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ------------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm | 0.27 | [ 0.09, 0.44] | 99.75%** | Beta (5.20 +- 5.20) | 23.04** | 37.85***
## Confidence_Real | AI_Enthusiasm | 0.24 | [ 0.07, 0.41] | 99.50%** | Beta (5.20 +- 5.20) | 8.00* | 10.91**
## Confidence_Fake | AI_Danger | -0.18 | [-0.35, 0.01] | 96.70% | Beta (5.20 +- 5.20) | 1.61 | 1.01
## n_Real | AI_Danger | 0.17 | [-0.01, 0.34] | 96.67% | Beta (5.20 +- 5.20) | 1.49 | 0.943
##
## Observations: 100
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
##
## Parameter1 | Parameter2 | rho | 95% CI | pd | Prior | BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | FFNI_AcclaimSeeking | 0.26 | [ 0.09, 0.43] | 99.67%** | Beta (5.20 +- 5.20) | 14.38** | 53.44***
## Confidence_Fake | FFNI_AcclaimSeeking | 0.22 | [ 0.04, 0.40] | 98.85%* | Beta (5.20 +- 5.20) | 4.52* | 6.26*
## Confidence_Real | FFNI_GrandioseFantasies | 0.22 | [ 0.02, 0.38] | 99.08%** | Beta (5.20 +- 5.20) | 4.18* | 6.07*
## n_Real | FFNI_AcclaimSeeking | 0.19 | [ 0.00, 0.36] | 97.70%* | Beta (5.20 +- 5.20) | 2.21 | 2.78
## Confidence_Fake | FFNI_GrandioseFantasies | 0.19 | [ 0.00, 0.37] | 97.10%* | Beta (5.20 +- 5.20) | 1.93 | 1.33
## Confidence_Real | FFNI_ReactiveAnger | 0.15 | [-0.03, 0.32] | 94.80% | Beta (5.20 +- 5.20) | 1.12 | 1.92
## Confidence_Fake | FFNI_Manipulativeness | 0.15 | [-0.05, 0.31] | 93.95% | Beta (5.20 +- 5.20) | 1.04 | 0.776
##
## Observations: 100
r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)
p1 <- plot_correlation(dfsub,
x = "IPIP6_HonestyHumility",
y = "Confidence_Real",
ylab = "Confidence that the stimulus is real",
xlab = "Honesty-Humility",
fillx = "#00BCD4",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p2 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is fake",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p3 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "AI_Enthusiasm",
ylab = "Confidence that the stimulus is real",
xlab = "Enthusiasm about AI technology",
fillx = "#607D8B",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p4 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
p5 <- plot_correlation(dfsub,
y = "Confidence_Fake",
x = "FFNI_AcclaimSeeking",
ylab = "Confidence that the stimulus is fake",
xlab = "Narcissism (Acclaim Seeking)",
fillx = "#FF9800",
fill = "#3F51B5"
) +
scale_y_continuous(labels=scales::percent)
p6 <- plot_correlation(dfsub,
y = "Confidence_Real",
x = "FFNI_GrandioseFantasies",
ylab = "Confidence that the stimulus is real",
xlab = "Narcissism (Grandiose Fantasies)",
fillx = "#FFC107",
fill = "#D81B60"
) +
scale_y_continuous(labels=scales::percent)
fig <- wrap_elements(fig1a) /
wrap_elements(
((p3 / p2) | (p1 / p6) | (p4 / p5)) +
plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
) +
plot_layout(heights = c(1.1, 0.9))
ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)
Social Anxiety